home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / symbols.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-06-17  |  14.1 KB  |  672 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48. /* NUM_HASH_BUCKETS is the number of symbol scm_hash table buckets. 
  49.  */
  50. #define NUM_HASH_BUCKETS 137
  51.  
  52.  
  53.  
  54.  
  55. /* {Symbols}
  56.  */
  57.  
  58. #ifdef __STDC__
  59. unsigned long 
  60. scm_strhash (unsigned char *str, sizet len, unsigned long n)
  61. #else
  62. unsigned long 
  63. scm_strhash (str, len, n)
  64.      unsigned char *str;
  65.      sizet len;
  66.      unsigned long n;
  67. #endif
  68. {
  69.   if (len > 5)
  70.     {
  71.       sizet i = 5;
  72.       unsigned long h = 264 % n;
  73.       while (i--)
  74.     h = ((h << 8) + ((unsigned) (scm_downcase[str[h % len]]))) % n;
  75.       return h;
  76.     }
  77.   else
  78.     {
  79.       sizet i = len;
  80.       unsigned long h = 0;
  81.       while (i)
  82.     h = ((h << 8) + ((unsigned) (scm_downcase[str[--i]]))) % n;
  83.       return h;
  84.     }
  85. }
  86.  
  87. int scm_symhash_dim = NUM_HASH_BUCKETS;
  88.  
  89.  
  90. /* scm_sym2vcell
  91.  * looks up the symbol in the symhash table. 
  92.  */
  93. #ifdef __STDC__
  94. SCM 
  95. scm_sym2vcell (SCM sym, SCM thunk, SCM definep)
  96. #else
  97. SCM 
  98. scm_sym2vcell (sym, thunk, definep)
  99.      SCM sym;
  100.      SCM thunk;
  101.      SCM definep;
  102. #endif
  103. {
  104.   if (NIMP(thunk))
  105.     {
  106.       SCM var = scm_apply (thunk, sym, scm_cons(definep, listofnull));
  107.  
  108.       if (var == BOOL_F)
  109.     return BOOL_F;
  110.       else
  111.     {
  112.       if (IMP(var) || !VARIABLEP (var))
  113.         scm_wta (sym, "strangely interned symbol? ", "");
  114.       return VARVCELL (var);
  115.     }
  116.     }
  117.   else
  118.     {
  119.       SCM lsym, z;
  120.       sizet scm_hash = scm_strhash (UCHARS (sym), (sizet) LENGTH (sym),
  121.                     (unsigned long) scm_symhash_dim);
  122.       for (lsym = VELTS (symhash)[scm_hash]; NIMP (lsym); lsym = CDR (lsym))
  123.     {
  124.       z = CAR (lsym);
  125.       if (CAR (z) == sym)
  126.         return z;
  127.     }
  128.       /* DEFINEP is ignored here on the grounds that only 
  129.        * symbols interned normally (on creation) in the symhash table
  130.        * ought to be used for definitions in the symhash table.  
  131.        * Therefore, SYM ought to already be interned and should have been
  132.        * found by the preceeding for loop.  If it wasn't, it can only
  133.        * be an error.
  134.        */
  135.       return scm_wta (sym, "uninterned symbol? ", "");
  136.     }
  137. }
  138.  
  139. /* scm_sym2ovcell
  140.  * looks up the symbol in an arbitrary obarray (defaulting to symhash).
  141.  */
  142. #ifdef __STDC__
  143. SCM 
  144. scm_sym2ovcell_soft (SCM sym, SCM obarray)
  145. #else
  146. SCM 
  147. scm_sym2ovcell_soft (sym, obarray)
  148.      SCM sym;
  149.      SCM obarray;
  150. #endif
  151. {
  152.   SCM lsym, z;
  153.   sizet scm_hash;
  154.  
  155.   scm_hash = scm_strhash (UCHARS (sym),
  156.               (sizet) LENGTH (sym),
  157.               LENGTH (obarray));
  158.   for (lsym = VELTS (obarray)[scm_hash];
  159.        NIMP (lsym);
  160.        lsym = CDR (lsym))
  161.     {
  162.       z = CAR (lsym);
  163.       if (CAR (z) == sym)
  164.     return z;
  165.     }
  166.   return BOOL_F;
  167. }
  168.  
  169. #ifdef __STDC__
  170. SCM 
  171. scm_sym2ovcell (SCM sym, SCM obarray)
  172. #else
  173. SCM 
  174. scm_sym2ovcell (sym, obarray)
  175.      SCM sym;
  176.      SCM obarray;
  177. #endif
  178. {
  179.   SCM answer;
  180.   answer = scm_sym2ovcell_soft (sym, obarray);
  181.   if (answer != BOOL_F)
  182.     return answer;
  183.   scm_wta (sym, "uninterned symbol? ", "");
  184.   return UNSPECIFIED;        /* not reached */
  185. }
  186.  
  187. #ifdef __STDC__
  188. SCM 
  189. scm_intern_obarray_soft (char *name, sizet len, SCM obarray, int softness)
  190. #else
  191. SCM 
  192. scm_intern_obarray_soft (name, len, obarray, softness)
  193.      char *name;
  194.      sizet len;
  195.      SCM obarray;
  196.      int softness;
  197. #endif
  198. {
  199.   SCM lsym;
  200.   SCM z;
  201.   register sizet i;
  202.   register unsigned char *tmp;
  203.   sizet scm_hash;
  204.  
  205.   i = len;
  206.   tmp = (unsigned char *) name;
  207.  
  208.   if (obarray == BOOL_F)
  209.     {
  210.       scm_hash = scm_strhash (tmp, i, 1019);
  211.       goto uninterned_symbol;
  212.     }
  213.  
  214.   scm_hash = scm_strhash (tmp, i, LENGTH(obarray));
  215.  
  216.   if (softness == -1)
  217.     goto mustintern_symbol;
  218.  
  219.   for (lsym = VELTS (obarray)[scm_hash]; NIMP (lsym); lsym = CDR (lsym))
  220.     {
  221.       z = CAR (lsym);
  222.       z = CAR (z);
  223.       tmp = UCHARS (z);
  224.       if (LENGTH (z) != len)
  225.     goto trynext;
  226.       for (i = len; i--;)
  227.     if (((unsigned char *) name)[i] != tmp[i])
  228.       goto trynext;
  229.       return CAR (lsym);
  230.     trynext:;
  231.     }
  232.  
  233.  uninterned_symbol:
  234.   if (softness)
  235.     return BOOL_F;
  236.  
  237.  mustintern_symbol:
  238.   lsym = scm_makfromstr (name, len, SYMBOL_SLOTS);
  239.   DEFER_INTS;
  240.   SETLENGTH (lsym, (long) len, tc7_msymbol);
  241.   SYMBOL_HASH (lsym) = scm_hash;
  242.   ALLOW_INTS;
  243.   if (obarray == BOOL_F)
  244.     {
  245.       SCM answer;
  246.       NEWCELL (answer);
  247.       DEFER_INTS;
  248.       CAR (answer) = lsym;
  249.       CDR (answer) = SCM_UNDEFINED;
  250.       ALLOW_INTS;
  251.       return answer;
  252.     }
  253.   else
  254.     return CAR (VELTS (obarray)[scm_hash] =
  255.         scm_acons (lsym, SCM_UNDEFINED, VELTS (obarray)[scm_hash]));
  256. }
  257.  
  258. #ifdef __STDC__
  259. SCM
  260. scm_intern_obarray (char *name, sizet len, SCM obarray)
  261. #else
  262. SCM
  263. scm_intern_obarray (name, len, obarray)
  264.      char *name;
  265.      sizet len;
  266.      SCM obarray;
  267. #endif
  268. {
  269.   return scm_intern_obarray_soft (name, len, obarray, 0);
  270. }
  271.  
  272.  
  273. #ifdef __STDC__
  274. SCM 
  275. scm_intern (char *name, sizet len)
  276. #else
  277. SCM 
  278. scm_intern (name, len)
  279.      char *name;
  280.      sizet len;
  281. #endif
  282. {
  283.   return scm_intern_obarray (name, len, symhash);
  284. }
  285.  
  286. #ifdef __STDC__
  287. SCM
  288. scm_intern0 (char * name)
  289. #else
  290. SCM
  291. scm_intern0 (name)
  292.      char * name;
  293. #endif
  294. {
  295.   return scm_intern (name, strlen (name));
  296. }
  297.  
  298.  
  299. #ifdef __STDC__
  300. SCM 
  301. scm_sysintern (char *name, SCM val)
  302. #else
  303. SCM 
  304. scm_sysintern (name, val)
  305.      char *name;
  306.      SCM val;
  307. #endif
  308. {
  309.   SCM easy_answer;
  310.   easy_answer = scm_intern_obarray_soft (name, strlen (name), symhash, 1);
  311.   if (NIMP (easy_answer))
  312.     {
  313.       CDR (easy_answer) = val;
  314.       return easy_answer;
  315.     }
  316.   else
  317.     {
  318.       SCM lsym;
  319.       sizet len = strlen (name);
  320.       register unsigned char *tmp = (unsigned char *) name;
  321.       sizet scm_hash = scm_strhash (tmp, len, (unsigned long) scm_symhash_dim);
  322.       NEWCELL (lsym);
  323.       SETLENGTH (lsym, (long) len, tc7_ssymbol);
  324.       SETCHARS (lsym, name);
  325.       lsym = scm_cons (lsym, val);
  326.       VELTS (symhash)[scm_hash] = scm_cons (lsym, VELTS (symhash)[scm_hash]);
  327.       return lsym;
  328.     }
  329. }
  330.  
  331.  
  332. PROC (s_symbol_p, "symbol?", 1, 0, 0, scm_symbol_p);
  333. #ifdef __STDC__
  334. SCM
  335. scm_symbol_p(SCM x)
  336. #else
  337. SCM
  338. scm_symbol_p(x)
  339.      SCM x;
  340. #endif
  341. {
  342.     if IMP(x) return BOOL_F;
  343.     return SYMBOLP(x) ? BOOL_T : BOOL_F;
  344. }
  345.  
  346. PROC (s_symbol_to_string, "symbol->string", 1, 0, 0, scm_symbol_to_string);
  347. #ifdef __STDC__
  348. SCM
  349. scm_symbol_to_string(SCM s)
  350. #else
  351. SCM
  352. scm_symbol_to_string(s)
  353.      SCM s;
  354. #endif
  355. {
  356.     ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_to_string);
  357.     return scm_makfromstr(CHARS(s), (sizet)LENGTH(s), 0);
  358. }
  359.  
  360. PROC (s_string_to_symbol, "string->symbol", 1, 0, 0, scm_string_to_symbol);
  361. #ifdef __STDC__
  362. SCM
  363. scm_string_to_symbol(SCM s)
  364. #else
  365. SCM
  366. scm_string_to_symbol(s)
  367.      SCM s;
  368. #endif
  369. {
  370.     ASSERT(NIMP(s) && ROSTRINGP(s), s, ARG1, s_string_to_symbol);
  371.     s = scm_intern(CHARS(s), (sizet)LENGTH(s));
  372.     return CAR(s);
  373. }
  374.  
  375.  
  376. PROC (s_string_to_obarray_symbol, "string->obarray-symbol", 2, 0, 0, scm_string_to_obarray_symbol);
  377. #ifdef __STDC__
  378. SCM
  379. scm_string_to_obarray_symbol(SCM o, SCM s)
  380. #else
  381. SCM
  382. scm_string_to_obarray_symbol(o, s)
  383.      SCM o;
  384.      SCM s;
  385. #endif
  386. {
  387.   ASSERT(NIMP(s) && ROSTRINGP(s), s, ARG2, s_string_to_obarray_symbol);
  388.   ASSERT((o == BOOL_F) || (NIMP(s) && VECTORP(o)),
  389.      o, ARG1, s_string_to_obarray_symbol);
  390.   s = scm_intern_obarray (CHARS(s), (sizet)LENGTH(s), o);
  391.   return CAR(s);
  392. }
  393.  
  394. PROC (s_intern_symbol, "intern-symbol", 2, 0, 0, scm_intern_symbol);
  395. #ifdef __STDC__
  396. SCM
  397. scm_intern_symbol(SCM o, SCM s)
  398. #else
  399. SCM
  400. scm_intern_symbol(o, s)
  401.      SCM o;
  402.      SCM s;
  403. #endif
  404. {
  405.         sizet hval;
  406.     ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_intern_symbol);
  407.     if (o == BOOL_F)
  408.       o = symhash;
  409.     ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_intern_symbol);
  410.     hval = scm_strhash (UCHARS (s), LENGTH (s), LENGTH(o));
  411.     /* If the symbol is already interned, simply return. */
  412.     {
  413.       SCM lsym;
  414.       SCM sym;
  415.       for (lsym = VELTS (o)[hval];
  416.            NIMP (lsym);
  417.            lsym = CDR (lsym))
  418.         {
  419.           sym = CAR (lsym);
  420.           if (CAR (sym) == s)
  421.         return UNSPECIFIED;
  422.         }
  423.       VELTS (o)[hval] =
  424.         scm_acons (s, SCM_UNDEFINED, VELTS (o)[hval]);
  425.     }
  426.     return UNSPECIFIED;
  427. }
  428.  
  429. PROC (s_unintern_symbol, "unintern-symbol", 2, 0, 0, scm_unintern_symbol);
  430. #ifdef __STDC__
  431. SCM
  432. scm_unintern_symbol(SCM o, SCM s)
  433. #else
  434. SCM
  435. scm_unintern_symbol(o, s)
  436.      SCM o;
  437.      SCM s;
  438. #endif
  439. {
  440.         sizet hval;
  441.     ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_unintern_symbol);
  442.     if (o == BOOL_F)
  443.       o = symhash;
  444.     ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_unintern_symbol);
  445.     hval = scm_strhash (UCHARS (s), LENGTH (s), LENGTH(o));
  446.     {
  447.       SCM lsym_follow;
  448.       SCM lsym;
  449.       SCM sym;
  450.       for (lsym = VELTS (o)[hval], lsym_follow = BOOL_F;
  451.            NIMP (lsym);
  452.            lsym_follow = lsym, lsym = CDR (lsym))
  453.         {
  454.           sym = CAR (lsym);
  455.           if (CAR (sym) == s)
  456.         {
  457.           /* Found the symbol to unintern. */
  458.           if (lsym_follow == BOOL_F)
  459.             VELTS(o)[hval] = lsym;
  460.           else
  461.             CDR(lsym_follow) = CDR(lsym);
  462.           return BOOL_T;
  463.         }
  464.         }
  465.     }
  466.     return BOOL_F;
  467. }
  468.  
  469. PROC (s_symbol_binding, "symbol-binding", 2, 0, 0, scm_symbol_binding);
  470. #ifdef __STDC__
  471. SCM
  472. scm_symbol_binding (SCM o, SCM s)
  473. #else
  474. SCM
  475. scm_symbol_binding (o, s)
  476.      SCM o;
  477.      SCM s;
  478. #endif
  479. {
  480.   SCM vcell;
  481.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_binding);
  482.   if (o == BOOL_F)
  483.     o = symhash;
  484.   ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_binding);
  485.   vcell = scm_sym2ovcell (s, o);
  486.   return CDR(vcell);
  487. }
  488.  
  489.  
  490. PROC (s_symbol_interned_p, "symbol-interned?", 2, 0, 0, scm_symbol_interned_p);
  491. #ifdef __STDC__
  492. SCM
  493. scm_symbol_interned_p (SCM o, SCM s)
  494. #else
  495. SCM
  496. scm_symbol_interned_p (o, s)
  497.      SCM o;
  498.      SCM s;
  499. #endif
  500. {
  501.   SCM vcell;
  502.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_interned_p);
  503.   if (o == BOOL_F)
  504.     o = symhash;
  505.   ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_interned_p);
  506.   vcell = scm_sym2ovcell_soft (s, o);
  507.   return (NIMP(vcell)
  508.       ? BOOL_T
  509.       : BOOL_F);
  510. }
  511.  
  512.  
  513. PROC (s_symbol_bound, "symbol-bound", 2, 0, 0, scm_symbol_bound);
  514. #ifdef __STDC__
  515. SCM 
  516. scm_symbol_bound (SCM o, SCM s)
  517. #else
  518. SCM 
  519. scm_symbol_bound (o, s)
  520.      SCM o;
  521.      SCM s;
  522. #endif
  523. {
  524.   SCM vcell;
  525.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_bound);
  526.   if (o == BOOL_F)
  527.     o = symhash;
  528.   ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_bound);
  529.   vcell = scm_sym2ovcell_soft (s, o);
  530.   return ((  NIMP(vcell)
  531.        && (CDR(vcell) != SCM_UNDEFINED))
  532.       ? BOOL_T
  533.       : BOOL_F);
  534. }
  535.  
  536.  
  537. PROC (s_symbol_set_x, "symbol-set!", 3, 0, 0, scm_symbol_set_x);
  538. #ifdef __STDC__
  539. SCM 
  540. scm_symbol_set_x (SCM o, SCM s, SCM v)
  541. #else
  542. SCM 
  543. scm_symbol_set_x (o, s, v)
  544.      SCM o;
  545.      SCM s;
  546.      SCM v;
  547. #endif
  548. {
  549.   SCM vcell;
  550.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_set_x);
  551.   if (o == BOOL_F)
  552.     o = symhash;
  553.   ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_set_x);
  554.   vcell = scm_sym2ovcell (s, o);
  555.   CDR(vcell) = v;
  556.   return UNSPECIFIED;
  557. }
  558.  
  559. static void
  560. msymbolize (s)
  561.      SCM s;
  562. {
  563.   SCM string;
  564.   string = scm_makfromstr (CHARS (s), LENGTH (s), SYMBOL_SLOTS);
  565.   DEFER_INTS;
  566.   CHARS (s) = CHARS (string);
  567.   SETLENGTH (s, LENGTH (s), tc7_msymbol);
  568.   CDR (string) = EOL;
  569.   CAR (string) = EOL;
  570.   ALLOW_INTS;
  571. }
  572.  
  573.  
  574. PROC (s_symbol_fref, "symbol-fref", 1, 0, 0, scm_symbol_fref);
  575. #ifdef __STDC__
  576. SCM
  577. scm_symbol_fref (SCM s)
  578. #else
  579. SCM
  580. scm_symbol_fref (s)
  581.      SCM s;
  582. #endif
  583. {
  584.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_fref);
  585.   if (TYP7(s) == tc7_ssymbol)
  586.     msymbolize (s);
  587.   return SYMBOL_FUNC (s);
  588. }
  589.  
  590.  
  591. PROC (s_symbol_pref, "symbol-pref", 1, 0, 0, scm_symbol_pref);
  592. #ifdef __STDC__
  593. SCM
  594. scm_symbol_pref (SCM s)
  595. #else
  596. SCM
  597. scm_symbol_pref (s)
  598.      SCM s;
  599. #endif
  600. {
  601.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_pref);
  602.   if (TYP7(s) == tc7_ssymbol)
  603.     msymbolize (s);
  604.   return SYMBOL_PROPS (s);
  605. }
  606.  
  607.  
  608. PROC (s_symbol_fset_x, "symbol-fset!", 2, 0, 0, scm_symbol_fset_x);
  609. #ifdef __STDC__
  610. SCM
  611. scm_symbol_fset_x (SCM s, SCM val)
  612. #else
  613. SCM
  614. scm_symbol_fset_x (s, val)
  615.      SCM s;
  616.      SCM val;
  617. #endif
  618. {
  619.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_fset_x);
  620.   if (TYP7(s) == tc7_ssymbol)
  621.     msymbolize (s);
  622.   SYMBOL_FUNC (s) = val;
  623.   return UNSPECIFIED;
  624. }
  625.  
  626.  
  627. PROC (s_symbol_pset_x, "symbol-pset!", 2, 0, 0, scm_symbol_pset_x);
  628. #ifdef __STDC__
  629. SCM
  630. scm_symbol_pset_x (SCM s, SCM val)
  631. #else
  632. SCM
  633. scm_symbol_pset_x (s, val)
  634.      SCM s;
  635.      SCM val;
  636. #endif
  637. {
  638.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_pset_x);
  639.   if (TYP7(s) == tc7_ssymbol)
  640.     msymbolize (s);
  641.   SYMBOL_PROPS (s) = val;
  642.   return UNSPECIFIED;
  643. }
  644.  
  645.  
  646. PROC (s_symbol_hash, "symbol-hash", 1, 0, 0, scm_symbol_hash);
  647. #ifdef __STDC__
  648. SCM
  649. scm_symbol_hash (SCM s)
  650. #else
  651. SCM
  652. scm_symbol_hash (s)
  653.      SCM s;
  654. #endif
  655. {
  656.   ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_hash);
  657.   return MAKINUM ((unsigned long)s ^ SYMBOL_HASH (s));
  658. }
  659.  
  660.  
  661. #ifdef __STDC__
  662. void
  663. scm_init_symbols (void)
  664. #else
  665. void
  666. scm_init_symbols ()
  667. #endif
  668. {
  669. #include "symbols.x"
  670. }
  671.  
  672.